home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / math.swg / 0130_Calculate a formula using recursion.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1997-08-30  |  13.4 KB  |  568 lines
  1. {$S-}
  2. {$M 65520,0,655360}
  3. {$N+}
  4.  
  5. { Cal.pas by Colin Lamarre, 1991
  6.   Email: lamarre@vir.com
  7.  
  8.   This program calculates a formula using recursion.
  9.  
  10. }
  11.  
  12. const
  13.   digits : set of char = ['0'..'9', '.', 'E'];
  14.  
  15. var
  16.   answer : extended;
  17.   rcal : string;
  18.   print : boolean;
  19.   i : integer;
  20.  
  21. procedure error(cal : string; var i : integer);
  22. begin
  23.   if print then
  24.   begin
  25.     writeln(copy(cal, i - 5, 10) + ' error.');
  26.     print := false;
  27.   end;
  28.   i := length(cal) + 1;
  29. end;
  30.  
  31. function clean(var toupper : string) : boolean;
  32. var
  33.   i, l, r : integer;
  34.   t : string;
  35. begin
  36.   print := true;
  37.   t := '';
  38.   l := 0;
  39.   r := 0;
  40.   for i := 1 to length(toupper) do
  41.     if toupper[i] <> ' ' then
  42.     begin
  43.       t := t + upcase(toupper[i]);
  44.       if toupper[i] = '(' then
  45.         l := l + 1;
  46.       if toupper[i] = ')' then
  47.         r := r + 1;
  48.     end;
  49.   if r <> l then
  50.   begin
  51.     writeln('Missing brackets');
  52.     clean := false;
  53.   end
  54.   else
  55.   begin
  56.     if t = '' then
  57.       toupper := '0'
  58.     else
  59.       toupper := t;
  60.     clean := true;
  61.   end;
  62. end;
  63.  
  64. function fstr(x : extended) : string;
  65. var
  66.   s : string;
  67. begin
  68.   str(x:1:9, s);
  69.   if s[1] = ' ' then
  70.     delete(s, 1, 1);
  71.   fstr := s;
  72. end;
  73.  
  74. function fval(s : string) : extended;
  75. var
  76.   x : extended;
  77.   code : integer;
  78. begin
  79.   val(s, x, code);
  80.   fval := x;
  81. end;
  82.  
  83. function prevnum(var temp : string; i : integer) : extended;
  84. var
  85.   oldi : integer;
  86. begin
  87.   oldi := i;
  88.   while ((temp[i] in digits) or ((temp[i - 1] = 'E') and (temp[i] in ['+', '-']))) and (i >= 1) do
  89.     dec(i);
  90.   if (temp[i] in ['+', '-']) and ((i = 1) or (temp[i - 1] in ['+', '-', '*', '/'])) then
  91.     dec(i);
  92.   prevnum := fval(copy(temp, i + 1, oldi - i));
  93.   delete(temp, i + 1, oldi - i);
  94. end;
  95.  
  96. function signs(cal : string; var i : integer) : integer;
  97. var
  98.   sign : integer;
  99. begin
  100.   sign := 1;
  101.   repeat
  102.     if cal[i] = '-' then
  103.     begin
  104.       sign := sign * -1;
  105.       inc(i);
  106.     end
  107.     else
  108.     if cal[i] = '+' then
  109.       inc(i);
  110.   until not(cal[i] in ['-', '+']);
  111.   signs := sign;
  112. end;
  113.  
  114. function nextnum(cal : string; var i : integer) : extended;
  115. var
  116.   temp : string;
  117.   sign : integer;
  118. begin
  119.   temp := '';
  120.   sign := signs(cal, i);
  121.   while (cal[i] in digits) and (i <= length(cal)) do
  122.   begin
  123.     temp := temp + cal[i];
  124.     inc(i);
  125.     if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
  126.     begin
  127.       temp := temp + cal[i];
  128.       inc(i);
  129.     end;
  130.   end;
  131.   nextnum := sign * fval(temp);
  132. end;
  133.  
  134. function getbrackets(cal : string; var i : integer) : string;
  135. var
  136.   count : integer;
  137.   temp : string;
  138. begin
  139.   count := 1;
  140.   temp := '';
  141.   repeat
  142.     inc(i);
  143.     if cal[i] = '(' then
  144.       count := count + 1;
  145.     if cal[i] = ')' then
  146.       count := count - 1;
  147.     temp := temp + cal[i];
  148.   until (cal[i] = ')') and (count = 0);
  149.   delete(temp, length(temp), 1);
  150.   inc(i);
  151.   getbrackets := temp;
  152. end;
  153.  
  154. function doadd(temp : string) : extended;
  155. var
  156.   i : integer;
  157.   tot : extended;
  158. begin
  159.   i := 1;
  160.   tot := nextnum(temp, i);
  161.   repeat
  162.     inc(i);
  163.     case temp[i - 1] of
  164.       '+' : tot := tot + nextnum(temp, i);
  165.       '-' : tot := tot - nextnum(temp, i);
  166.     end;
  167.   until i > length(temp);
  168.   doadd := tot;
  169. end;
  170.  
  171. function domuls(cal : string) : extended;
  172. var
  173.   i, sign : integer;
  174.   temp, s : string;
  175. begin
  176.   i := 1;
  177.   temp := '';
  178.   repeat
  179.     case cal[i] of
  180.       '+', '-' : begin
  181.                    temp := temp + cal[i];
  182.                    inc(i);
  183.                  end;
  184.  
  185.       '*' : begin
  186.               inc(i);
  187.               sign := signs(cal, i);
  188.               if cal[i] in digits then
  189.               begin
  190.                 s := fstr(sign * prevnum(temp, length(temp)) * nextnum(cal,i));
  191.                 temp := temp + s;
  192.               end
  193.               else
  194.               if cal[i] = '(' then
  195.               begin
  196.                 s := fstr(sign * prevnum(temp, length(temp)) * domuls(getbrackets(cal, i)));
  197.                 temp := temp + s;
  198.               end
  199.               else
  200.                 error(cal, i);
  201.             end;
  202.  
  203.       '/' : begin
  204.               inc(i);
  205.               sign := signs(cal, i);
  206.               if cal[i] in digits then
  207.               begin
  208.                 s := fstr(sign * prevnum(temp, length(temp)) / nextnum(cal, i));
  209.                 temp := temp + s;
  210.               end
  211.               else
  212.               if cal[i] = '(' then
  213.               begin
  214.                 s := fstr(prevnum(temp, length(temp)) / (sign * domuls(getbrackets(cal, i))));
  215.                 temp := temp + s;
  216.               end
  217.               else
  218.                 error(cal, i);
  219.             end;
  220.  
  221.       '0'..'9', '.' : while (cal[i] in digits) and (i <= length(cal)) do
  222.                       begin
  223.                         temp := temp + cal[i];
  224.                         inc(i);
  225.                         if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
  226.                         begin
  227.                           temp := temp + cal[i];
  228.                           inc(i);
  229.                         end;
  230.                       end;
  231.  
  232.       '(' : temp := temp + fstr(domuls(getbrackets(cal, i)));
  233.  
  234.       else
  235.         error(cal, i);
  236.     end;
  237.   until i > length(cal);
  238.   domuls := doadd(temp);
  239. end;
  240.  
  241. function dopowers(cal : string) : string;
  242. var
  243.   i, c : integer;
  244.   x, f : extended;
  245.  
  246.   function fcnt(var cal : string; var i : integer) : integer;
  247.   var
  248.     j : integer;
  249.   begin
  250.     j := 0;
  251.     while cal[i] = '!' do
  252.     begin
  253.       inc(j);
  254.       dec(i);
  255.     end;
  256.     inc(i);
  257.     delete(cal, i, j);
  258.     fcnt := j;
  259.   end;
  260.  
  261.   function fact(x : extended) : extended;
  262.   var
  263.     k, n : word;
  264.     ans : extended;
  265.   begin
  266.     ans := 1;
  267.     if x < 0 then
  268.       fact := ans / (x - x);
  269.     n := trunc(x);
  270.     for k := 2 to n do
  271.       ans := k * ans;
  272.     fact := ans;
  273.   end;
  274.  
  275.   function getprev(var cal : string; var i : integer) : extended;
  276.   var
  277.     oldi, count : integer;
  278.   begin
  279.     dec(i);
  280.     oldi := i;
  281.     if cal[i] <> ')' then
  282.     begin
  283.       while ((cal[i] in digits) or ((cal[i - 1] = 'E') and (cal[i] in ['+', '-']))) and (i >= 1) do
  284.         dec(i);
  285.       if (cal[i] in ['+', '-']) and ((i = 1) or (cal[i - 1] in ['+', '-', '*', '/'])) then
  286.         dec(i);
  287.       getprev := fval(copy(cal, i + 1, oldi - i));
  288.       delete(cal, i + 1, oldi - i);
  289.     end
  290.     else
  291.     begin
  292.       count := 1;
  293.       while (cal[i] <> '(') and (count <> 0) and (i >= 1) do
  294.       begin
  295.         dec(i);
  296.         if cal[i] = ')' then
  297.           count := count + 1;
  298.         if cal[i] = '(' then
  299.           count := count - 1;
  300.       end;
  301.       getprev := domuls(dopowers(copy(cal, i + 1, oldi - i - 1)));
  302.       delete(cal, i, oldi - i + 1);
  303.       dec(i);
  304.     end;
  305.   end;
  306.  
  307.   function getnext(var cal : string; i : integer) : extended;
  308.   var
  309.     oldi, sign, count : integer;
  310.     temp : string;
  311.   begin
  312.     oldi := i;
  313.     inc(i);
  314.     temp := '';
  315.     sign := signs(cal, i);
  316.     if cal[i] <> '(' then
  317.     begin
  318.       while (cal[i] in digits) and (i <= length(cal)) do
  319.       begin
  320.         temp := temp + cal[i];
  321.         inc(i);
  322.         if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
  323.         begin
  324.           temp := temp + cal[i];
  325.           inc(i);
  326.         end;
  327.       end;
  328.       getnext := sign * fval(temp);
  329.       delete(cal, oldi, i - oldi);
  330.     end
  331.     else
  332.     begin
  333.       count := 1;
  334.       temp := '';
  335.       repeat
  336.         inc(i);
  337.         if cal[i] = '(' then
  338.           count := count + 1;
  339.         if cal[i] = ')' then
  340.           count := count - 1;
  341.         temp := temp + cal[i];
  342.       until (cal[i] = ')') and (count = 0);
  343.       delete(temp, length(temp), 1);
  344.       getnext := sign * domuls(dopowers(temp));
  345.       delete(cal, oldi, i - oldi + 1);
  346.     end;
  347.   end;
  348.  
  349. begin
  350.   i := length(cal);
  351.   repeat
  352.     case cal[i] of
  353.       '^' : begin
  354.               x := getnext(cal, i);
  355.               if cal[i - 1] = '!' then
  356.               begin
  357.                 dec(i);
  358.                 c := fcnt(cal, i);
  359.                 f := getprev(cal, i);
  360.                 for c := 1 to c do
  361.                   f := fact(f);
  362.                 insert(fstr(exp(x * ln(f))), cal, i + 1);
  363.               end
  364.               else
  365.                 insert(fstr(exp(x * ln(getprev(cal, i)))), cal, i + 1);
  366.             end;
  367.  
  368.       '!' : begin
  369.               c := fcnt(cal, i);
  370.               f := getprev(cal, i);
  371.               for c := 1 to c do
  372.                 f := fact(f);
  373.               insert(fstr(f), cal, i + 1);
  374.             end;
  375.  
  376.       else
  377.         dec(i);
  378.     end;
  379.   until i < 1;
  380.   dopowers := cal;
  381. end;
  382.  
  383. function dofuncs(cal : string) : string;
  384. var
  385.   i : integer;
  386.   temp : string;
  387.  
  388.   function next3 : string;
  389.   begin
  390.     next3 := cal[i + 1] + cal[i + 2] + cal[i + 3];
  391.   end;
  392.  
  393.   function asin(ratio : extended) : extended;
  394.   begin
  395.     asin := arctan(ratio / sqrt((1 - ratio) * (1 + ratio)));
  396.   end;
  397.  
  398.   function acos(ratio : extended) : extended;
  399.   begin
  400.     acos := arctan(sqrt((1 - ratio) * (1 + ratio)) / ratio);
  401.   end;
  402.  
  403.   function atan(ratio : extended) : extended;
  404.   begin
  405.     atan := arctan(ratio);
  406.   end;
  407.  
  408.   function tan(angle : extended) : extended;
  409.   begin
  410.     tan := sin(angle) / cos(angle);
  411.   end;
  412.  
  413.   function cot(angle : extended) : extended;
  414.   begin
  415.     cot := cos(angle) / sin(angle);
  416.   end;
  417.  
  418.   function log(x : extended) : extended;
  419.   begin
  420.     log := ln(x) / 2.302585093;
  421.   end;
  422.  
  423. begin
  424.   i := 1;
  425.   temp := '';
  426.   repeat
  427.     case cal[i] of
  428.       '+', '-',
  429.       '*', '/',
  430.       '(', ')',
  431.       '^', '!' : begin
  432.                    temp := temp + cal[i];
  433.                    inc(i);
  434.                  end;
  435.  
  436.       'S' : begin
  437.               if next3 = 'IN(' then
  438.               begin
  439.                 inc(i, 3);
  440.                 temp := temp + fstr(sin(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  441.               end
  442.               else
  443.               if next3 + cal[i + 4] = 'QRT(' then
  444.               begin
  445.                 inc(i, 4);
  446.                 temp := temp + fstr(sqrt(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  447.               end
  448.               else
  449.                 error(cal, i);
  450.             end;
  451.  
  452.       'C' : begin
  453.               if next3 = 'OS(' then
  454.               begin
  455.                 inc(i, 3);
  456.                 temp := temp + fstr(cos(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  457.               end
  458.               else
  459.               if next3 = 'OT(' then
  460.               begin
  461.                 inc(i, 3);
  462.                 temp := temp + fstr(cot(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  463.               end
  464.               else
  465.                 error(cal, i);
  466.             end;
  467.  
  468.       'T' : begin
  469.               if next3 = 'AN(' then
  470.               begin
  471.                 inc(i, 3);
  472.                 temp := temp + fstr(tan(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  473.               end
  474.               else
  475.                 error(cal, i);
  476.             end;
  477.  
  478.       'A' : begin
  479.               if next3 + cal[i + 4] = 'TAN(' then
  480.               begin
  481.                 inc(i, 4);
  482.                 temp := temp + fstr(atan(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  483.               end
  484.               else
  485.               if next3 + cal[i + 4] = 'COS(' then
  486.               begin
  487.                 inc(i, 4);
  488.                 temp := temp + fstr(acos(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  489.               end
  490.               else
  491.               if next3 + cal[i + 4] = 'SIN(' then
  492.               begin
  493.                 inc(i, 4);
  494.                 temp := temp + fstr(asin(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  495.               end
  496.               else
  497.               if next3 = 'BS(' then
  498.               begin
  499.                 inc(i, 3);
  500.                 temp := temp + fstr(abs(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  501.               end
  502.               else
  503.                 error(cal, i);
  504.             end;
  505.  
  506.       'L' : begin
  507.               if next3 = 'OG(' then
  508.               begin
  509.                 inc(i, 3);
  510.                 temp := temp + fstr(log(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  511.               end
  512.               else
  513.               if cal[i + 1] + cal[i + 2] = 'N(' then
  514.               begin
  515.                 inc(i, 2);
  516.                 temp := temp + fstr(ln(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  517.               end
  518.               else
  519.                 error(cal, i);
  520.             end;
  521.  
  522.       'E' : if next3 = 'XP(' then
  523.             begin
  524.               inc(i, 3);
  525.               temp := temp + fstr(exp(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
  526.             end;
  527.  
  528.       'P' : if cal[i + 1] = 'I' then
  529.             begin
  530.               inc(i, 2);
  531.               temp := temp + fstr(pi);
  532.             end
  533.             else
  534.               error(cal, i);
  535.  
  536.       '0'..'9', '.' : while (cal[i] in digits) and (i <= length(cal)) do
  537.                       begin
  538.                         temp := temp + cal[i];
  539.                         inc(i);
  540.                         if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
  541.                         begin
  542.                           temp := temp + cal[i];
  543.                           inc(i);
  544.                         end;
  545.                       end;
  546.  
  547.       else
  548.         error(cal, i);
  549.     end;
  550.   until i > length(cal);
  551.   dofuncs := temp;
  552. end;
  553.  
  554. begin
  555.   rcal := '';
  556.   for i := 1 to paramcount do
  557.     rcal := rcal + paramstr(i);
  558.  
  559.   if clean(rcal) then
  560.   begin
  561.     answer := domuls(dopowers(dofuncs(rcal)));
  562.     if print then
  563.       writeln(answer:1:9);
  564.   end;
  565.  
  566. end.
  567.  
  568.